home *** CD-ROM | disk | FTP | other *** search
/ HAM Radio 1997 / HAM Radio 1997.iso / vcls / simage / simage.pas < prev    next >
Pascal/Delphi Source File  |  1996-04-08  |  19KB  |  637 lines
  1. {Donated to the public domain 1-May-95 by Paul Peterson, Summit Software, Inc.}
  2. {Please report any problems to 72371,1136 via CIS Mail)
  3. {This component makes it much easer to display 256 color BMP files in
  4.  Delphi. It will scale the image (or a rectangle of the image) up or down to 
  5.  best fit into the designed size of the component. It includes a cropping 
  6.  tool that a user can use at run-time to frame the part of the image of 
  7.  interest. See the BMPView demo app for how this component is used.  The
  8.  'ChangeFromFile() method is the main way to control this component}
  9. unit Simage;
  10. interface
  11. uses
  12.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Forms, Controls, 
  13.   extctrls, StdCtrls;
  14.  
  15. Type
  16.   TCropHandle = (NoHandle,INNER,UR,UL,BR,BL,LS,RS,TS,BS);
  17. Const        
  18.   Yes = True;
  19.   No  = False;
  20. type
  21.   TSimage = class(TImage)
  22.     procedure loaded; override;
  23.     constructor create(AOwner : Tcomponent); override;
  24.     destructor Destroy; override;
  25.     procedure MouseMove(
  26.                      Shift : TShiftState; 
  27.                       X, Y : Integer); override;
  28.     procedure click; override;
  29.     procedure SizeAndShow;
  30.     procedure HideNow; 
  31.     procedure ChangeFromFile(
  32.             const FileName : string;
  33.                       Crop : Trect;
  34.               Show_Cropped : boolean;
  35.                Actual_Size : boolean);
  36.     procedure ReplaceWith(
  37.                  fromImage : TSimage;
  38.                       Crop : Trect;
  39.               Show_Cropped : boolean;
  40.                Actual_Size : boolean);
  41.     procedure ReDraw(
  42.                       Crop : Trect;
  43.               Show_Cropped : boolean;
  44.                Actual_Size : boolean);
  45.     function get_filename : string;
  46.     function get_rect : Trect;
  47.     procedure SetDesignedSize(
  48.                          t : integer;
  49.                          l : integer;
  50.                          w : integer;
  51.                          h : integer);  
  52.     procedure GetDesignedSize(
  53.                      Var t : integer;
  54.                      Var l : integer;
  55.                      Var w : integer;
  56.                      Var h : integer);
  57.     procedure draw_croptool(
  58.                       Crop : Trect); 
  59.     procedure croptool_off(
  60.                var changed : boolean;
  61.                   var Crop : Trect);
  62.     procedure croptool_on;
  63.   public
  64.     OrigPict : TPicture;
  65.     curfilename    : string;
  66.   private
  67.     procedure erasecrop;
  68.     function validcrop(
  69.                   var rect : Trect;
  70.                   var pict : Tpicture
  71.                          ) : boolean;  
  72.   private
  73.     oldx,
  74.     oldy           : integer;
  75.     DesignedTop,
  76.     DesignedLeft,
  77.     DesignedWidth,
  78.     DesignedHeight : integer;
  79.     CropRectActual,
  80.     CropRectScaled,
  81.     CropOutside    : Trect;
  82.     CropHands      : array[INNER..BS] of Trect;
  83.     CropCopy       : TBitmap;
  84.     CropChanged,
  85.     valid_crop,
  86.     ShowCropped,
  87.     ShowActualSize,
  88.     CropToolOn     : boolean;
  89.     CropMoveHandle : TCropHandle;
  90.     sratio         : real;
  91.   end;
  92.   procedure Register;
  93.  
  94. {------------------------------------------------------------------------}
  95. implementation
  96.  
  97. {------------------------------------------------------------------------}
  98. procedure Register;
  99. begin
  100.   RegisterComponents('Samples',[TSimage]); 
  101. end;
  102.  
  103. {------------------------------------------------------------------------}
  104. constructor TSimage.create(AOwner : Tcomponent);
  105. begin
  106.   inherited create(AOwner);
  107.   OrigPict := TPicture.create;
  108.   curfilename := '';
  109.   CropToolOn := no;
  110.   CropMoveHandle := noHandle;
  111.   valid_crop := no;
  112. end;
  113.  
  114. {------------------------------------------------------------------------}
  115. destructor TSimage.Destroy;
  116. begin
  117.   OrigPict.free;
  118.   inherited Destroy;
  119. end;
  120.  
  121. {------------------------------------------------------------------------}
  122. procedure TSimage.click; 
  123. begin
  124.   if (CropMoveHandle = noHandle) then inherited click;
  125. end;
  126.  
  127. {------------------------------------------------------------------------}
  128. procedure TSimage.MouseMove(
  129.                      Shift : TShiftState; 
  130.                       X, Y : Integer);
  131. var
  132.   cp      : TCropHandle;
  133.   found   : boolean;
  134.   xd,yd   : integer;
  135.   NewRect : Trect;
  136.  
  137. {------------------------------------------------------------------------}
  138.   function in_rect(var arect : Trect) : boolean;
  139.   begin
  140.     with arect do
  141.       in_rect := (x > left) and (x < right) and (y > top) and (y < bottom);
  142.   end;
  143.  
  144. {------------------------------------------------------------------------}
  145. {------------------------------------------------------------------------}
  146. begin 
  147.   inherited MouseMove(Shift,x,y);
  148.   if not CropToolOn then exit;
  149.   if (x < -10) or (y < -10) or (x > Width + 10) or (y > Height+ 10) then
  150.     exit;
  151.   found := no;
  152.   if (CropMoveHandle <> noHandle) and (ssLeft in shift) then 
  153.   begin
  154.     found := yes;
  155.     if (x <> oldx) or (y <> oldy) then
  156.     begin
  157.       NewRect := CropRectScaled;
  158.       with NewRect do
  159.       begin
  160.         xd := x - oldx;
  161.         yd := y - oldy;
  162.         case CropMoveHandle of 
  163.           INNER :
  164.             begin
  165.               inc(left,xd);
  166.               inc(right,xd);
  167.               inc(top,yd);
  168.               inc(bottom,yd);
  169.             end;
  170.           UR :
  171.             begin
  172.               inc(right,xd);
  173.               inc(top,yd);
  174.             end;
  175.           UL :
  176.             begin
  177.               inc(left,xd);
  178.               inc(top,yd);
  179.             end;
  180.           BR :
  181.             begin
  182.               inc(right,xd);
  183.               inc(bottom,yd);
  184.             end;
  185.           BL :
  186.             begin
  187.               inc(left,xd);
  188.               inc(bottom,yd);
  189.             end;
  190.           LS : inc(left,xd);
  191.           RS : inc(right,xd);
  192.           TS : inc(top,yd);
  193.           BS : inc(bottom,yd);
  194.         end;
  195.         if left >= right then
  196.           if xd > 0 then
  197.             right := left + 1
  198.           else
  199.             left := right - 1;
  200.         if top >= bottom then
  201.           if yd > 0 then
  202.             bottom := top + 1
  203.           else
  204.             top := bottom - 1;
  205.         if  (right >= 0) and (bottom >= 0) 
  206.           and (left <= width) and (top <= height) then
  207.         begin
  208.           EraseCrop;
  209.           CropRectScaled := NewRect;
  210.           draw_croptool(CropRectScaled);
  211.           CropChanged := yes;
  212.         end;
  213.       end;
  214.     end;
  215.   end
  216.   else
  217.   begin
  218.     if in_rect(CropOutside) then  
  219.     begin
  220.       for cp := INNER to high(TCropHandle) do
  221.         if in_rect(cropHands[cp]) then
  222.         begin
  223.           CropMoveHandle := cp; 
  224.           found := yes;
  225.           case cp of
  226.             inner : cursor := 2;
  227.             UR,BL : cursor := crSizeNESW;
  228.             UL,BR : cursor := crSizeNWSE;
  229.             LS,RS : cursor := crSizeWE;
  230.             TS,BS : cursor := crSizeNS;
  231.           end;
  232.           break;
  233.         end;
  234.     end;
  235.   end;
  236.   if not found then    
  237.   begin
  238.     cursor := crDefault;
  239.     CropMoveHandle := noHandle; 
  240.   end;
  241.   oldx := x;
  242.   oldy := y;
  243. end;            
  244.  
  245. {------------------------------------------------------------------------}
  246. procedure TSimage.loaded;
  247. begin
  248.   inherited loaded;
  249.   DesignedTop    := Top;
  250.   DesignedLeft   := Left;
  251.   DesignedWidth  := width;
  252.   DesignedHeight := height;
  253.   stretch := false;
  254.   autosize := false;
  255.   center := false;
  256. end;
  257.  
  258. {------------------------------------------------------------------------}
  259. function TSimage.validcrop(
  260.                   var rect : Trect;
  261.                   var pict : Tpicture
  262.                          ) : boolean;  
  263. begin
  264.   with rect,pict.bitmap do
  265.   begin
  266.     if left < 0 then left := width div 4;
  267.     if top < 0 then top := height div 4;
  268.     if right > width then right := (width div 4) * 3;
  269.     if bottom > height then bottom := (height div 4) * 3;
  270.     validcrop := ((left < right) and (top < bottom));
  271.   end;
  272. end;
  273.  
  274. {------------------------------------------------------------------------}
  275. procedure TSimage.ChangeFromFile(
  276.             const FileName : string;
  277.                       Crop : Trect;
  278.               Show_Cropped : boolean;
  279.                Actual_Size : boolean);
  280. var
  281.   dumbool : boolean;
  282.   rect : Trect;
  283.   l : longint;
  284.   SaveCursor : HCursor;
  285. begin
  286.   SaveCursor := screen.cursor;
  287.   screen.cursor := crHourGlass;
  288.   update;
  289.   if CropToolOn then croptool_off(dumbool,rect);
  290.   curfilename := filename;
  291.   if filename = '' then
  292.   begin
  293.     HideNow;
  294.     OrigPict.assign(nil);
  295.     picture.assign(nil);
  296.   end
  297.   else
  298.   begin
  299.     OrigPict.LoadFromFile(FileName);
  300.     CropRectActual := Crop;
  301.     ShowCropped := Show_Cropped;
  302.     ShowActualSize := Actual_Size;
  303.     valid_crop := validcrop(CropRectActual,OrigPict);
  304.     HideNow;
  305.     picture.assign(Origpict);
  306.     SizeAndShow;
  307.   end;
  308.   screen.cursor := SaveCursor;
  309. end;
  310.  
  311. {------------------------------------------------------------------------}
  312. procedure TSimage.ReplaceWith(
  313.                  fromImage : TSimage;
  314.                       Crop : Trect;
  315.               Show_Cropped : boolean;
  316.                Actual_Size : boolean);
  317. var
  318.   dumbool : boolean;
  319.   rect : Trect;
  320.   SaveCursor : HCursor;
  321. begin
  322.   SaveCursor := screen.cursor;
  323.   screen.cursor := crHourGlass;
  324.   if CropToolOn then croptool_off(dumbool,rect);
  325.   curfilename := fromImage.get_filename;
  326.   OrigPict.assign(fromImage.OrigPict);
  327.   CropRectActual := Crop;
  328.   ShowCropped := Show_Cropped;
  329.   ShowActualSize := Actual_Size;
  330.   valid_crop := validcrop(CropRectActual,Origpict);
  331.   HideNow;
  332.   picture.assign(Origpict);
  333.   SizeAndShow;
  334.   screen.cursor := SaveCursor;
  335. end;                   
  336.  
  337. {------------------------------------------------------------------------}
  338. procedure TSimage.ReDraw(
  339.                       Crop : Trect;
  340.               Show_Cropped : boolean;
  341.                Actual_Size : boolean);
  342. var
  343.   SaveCursor : HCursor;
  344. begin                               
  345.   SaveCursor := screen.cursor;
  346.   screen.cursor := crHourGlass;
  347.   if curfilename <> '' then
  348.   begin
  349.     CropRectActual := Crop;
  350.     ShowActualSize := Actual_Size;
  351.     ShowCropped := Show_Cropped;
  352.     valid_crop := validcrop(CropRectActual,Origpict);
  353.     HideNow;
  354.     picture.assign(Origpict);
  355.     SizeAndShow;
  356.   end;
  357.   screen.cursor := SaveCursor;
  358. end;                   
  359.        
  360. {------------------------------------------------------------------------}
  361. function TSimage.get_filename : string;
  362. begin
  363.   result := curfilename;
  364. end;
  365.  
  366. {------------------------------------------------------------------------}
  367. function TSimage.get_rect : Trect;
  368. begin
  369.   result := CropRectActual;
  370. end;
  371.  
  372. {------------------------------------------------------------------------}
  373. procedure TSimage.SetDesignedSize(
  374.                          t : integer;
  375.                          l : integer;
  376.                          w : integer;
  377.                          h : integer);
  378. begin
  379.   DesignedTop    := t;
  380.   DesignedLeft   := l;
  381.   DesignedWidth  := w;
  382.   DesignedHeight := h;
  383. end;
  384.  
  385. {------------------------------------------------------------------------}
  386. procedure TSimage.GetDesignedSize(
  387.                      Var t : integer;
  388.                      Var l : integer;
  389.                      Var w : integer;
  390.                      Var h : integer);
  391. begin
  392.   t := DesignedTop;
  393.   l := DesignedLeft;
  394.   w := DesignedWidth;
  395.   h := DesignedHeight;
  396. end;
  397.  
  398. {------------------------------------------------------------------------}
  399. procedure TSimage.HideNow;
  400. begin
  401.   hide;
  402.   update;                                 {causes hide to actually happen}
  403. end;
  404.  
  405. {------------------------------------------------------------------------}
  406. procedure TSimage.SizeAndShow;
  407. var
  408.   wratio,
  409.   hratio     : real;
  410.   recttop,
  411.   rectleft,
  412.   rectwidth,
  413.   rectheight,
  414.   wOffset,
  415.   hOffset    : integer;
  416.   new_width,
  417.   new_height : word;
  418.   rect : Trect;
  419. begin
  420.   if valid_crop and ShowCropped then
  421.   begin
  422.     with CropRectActual do
  423.     begin
  424.       recttop    := top;
  425.       rectleft   := left;
  426.       rectwidth  := right - left + 1;
  427.       rectheight := bottom - top + 1;
  428.     end
  429.   end
  430.   else
  431.   begin
  432.     with Picture do
  433.     begin
  434.       recttop    := 0;
  435.       rectleft   := 0;
  436.       rectwidth  := width;
  437.       rectheight := height;
  438.     end;
  439.   end;
  440.   if (rectwidth <> 0) and (rectheight <> 0) then
  441.   begin 
  442.     if ShowActualSize then
  443.     begin
  444.       sratio := 1.0;
  445.       new_width := rectwidth;
  446.       new_height := rectheight;
  447.     end            
  448.     else
  449.     begin
  450. {scale picture proportionary to fit into full designed size best}
  451.       wratio := DesignedWidth / rectwidth;
  452.       hratio := DesignedHeight / rectheight;
  453.       if wratio > hratio then
  454.         sratio := hratio
  455.       else
  456.         sratio := wratio;
  457.       new_width := trunc(rectwidth * sratio);
  458.       new_height := trunc(rectheight * sratio);
  459.       if new_width > DesignedWidth then new_width := DesignedWidth;
  460.       if new_height > DesignedHeight then new_Height := DesignedHeight;
  461.     end;
  462.     wOffset := (DesignedWidth - new_width) div 2;
  463.     if wOffset < 0 then wOffset := 0;
  464.     hOffset := (DesignedHeight - new_height) div 2;
  465.     if hOffset < 0 then hOffset := 0;
  466.     SetStretchBltMode(picture.bitmap.canvas.handle,STRETCH_DELETESCANS);
  467.     if sratio < 1 then
  468.     begin
  469.       With picture.bitmap.canvas do
  470.         StretchBlt(handle,0,0,new_width,new_height
  471.                         ,handle,rectleft,recttop,rectwidth,rectheight,srccopy);
  472.     end
  473.     else
  474.       if sratio > 1 then
  475.       begin
  476.         picture.bitmap.height := new_height;
  477.         picture.bitmap.width := new_width;
  478.         With picture.bitmap.canvas  do
  479.           StretchBlt(handle,0,0,new_width,new_height
  480.                     ,OrigPict.Bitmap.canvas.handle
  481.                     ,rectleft,recttop,rectwidth,rectheight,srccopy);
  482.       end
  483.       else                                                         {sratio = 1}
  484.       begin
  485.         if valid_crop and ShowCropped and ShowActualSize then
  486.           With picture.bitmap.canvas do
  487.             StretchBlt(handle,0,0,new_width,new_height
  488.                         ,handle,rectleft,recttop,rectwidth,rectheight,srccopy);
  489.       end;
  490.     SetBounds(DesignedLeft + wOffset,DesignedTop + hOffset
  491.                                                         ,new_width,new_height);
  492.   end;               
  493.   show;
  494. end;
  495.  
  496. {------------------------------------------------------------------------}
  497. procedure TSimage.erasecrop;
  498. begin
  499.   picture.bitmap.canvas.CopyRect(CropOutside,CropCopy.canvas,CropOutside);
  500. end;
  501.  
  502. {------------------------------------------------------------------------}
  503. procedure TSimage.croptool_off(
  504.                var changed : boolean;
  505.                   var Crop : Trect);
  506. begin
  507.   if CropToolOn then
  508.   begin
  509.     erasecrop;
  510.     CropCopy.free;
  511.     CropToolOn := no;
  512. {scale crop back to original picture units}
  513.     CropRectActual := CropRectScaled;
  514.     with CropRectActual do
  515.     begin
  516.       left   := trunc(left   / sratio);
  517.       right  := trunc(right  / sratio);
  518.       top    := trunc(top    / sratio);
  519.       bottom := trunc(bottom / sratio);
  520.     end;
  521.     changed := CropChanged;
  522.     Crop := CropRectActual;
  523.     valid_crop := validcrop(CropRectActual,Origpict);
  524.   end;
  525. end;           
  526.  
  527. {------------------------------------------------------------------------}
  528. procedure TSimage.draw_croptool(
  529.                       Crop : Trect); 
  530.  
  531. {------------------------------------------------------------------------}
  532.   procedure corner(  which : TCropHandle;
  533.                        x,y : integer);
  534.   begin
  535.     with canvas do
  536.     begin
  537.       brush.color := clwhite;
  538.       case which of
  539.         UR : 
  540.           begin
  541.             fillrect(rect(x+1,y-5,x+6,y));
  542.             cropHands[which] := rect(x,y-6,x+7,y+1);
  543.           end;
  544.         UL : 
  545.           begin
  546.             fillrect(rect(x-5,y-5,x,y));
  547.             cropHands[which] := rect(x-6,y-6,x+1,y+1);
  548.           end;
  549.         BR : 
  550.           begin
  551.             fillrect(rect(x+1,y+1,x+6,y+6));
  552.             cropHands[which] := rect(x,y,x+7,y+7);
  553.           end;
  554.         BL : 
  555.           begin
  556.             fillrect(rect(x-5,y+1,x,y+6));
  557.             cropHands[which] := rect(x-6,y,x+1,y+7);
  558.           end;
  559.         RS : 
  560.           begin
  561.             fillrect(rect(x+2,y-2,x+6,y+3));
  562.             cropHands[which] := rect(x+1,y-3,x+7,y+4);
  563.           end;
  564.         LS : 
  565.           begin
  566.             fillrect(rect(x-5,y-2,x-1,y+3));
  567.             cropHands[which] := rect(x-6,y-3,x,y+4);
  568.           end;
  569.         TS : 
  570.           begin
  571.             fillrect(rect(x-2,y-5,x+3,y-1));
  572.             cropHands[which] := rect(x-3,y-6,x+4,y);
  573.           end;
  574.         BS : 
  575.           begin
  576.             fillrect(rect(x-2,y+2,x+3,y+6));
  577.             cropHands[which] := rect(x-3,y+1,x+4,y+7);
  578.           end;
  579.       end;
  580.       brush.color := clblack;
  581.       framerect(cropHands[which]);
  582.     end; 
  583.   end;
  584.  
  585. {------------------------------------------------------------------------}
  586. {------------------------------------------------------------------------}
  587. begin
  588.   with CropRectScaled do                        {rect is actual pixels desired}
  589.   begin
  590. {save the hot area coors}
  591.     cropOutside := rect(left-6,top-6,right+7,bottom+7);
  592.     CropHands[INNER] := rect(left-2,top-2,right+3,bottom+3);
  593.     canvas.brush.color := clwhite;   {white boarder around pixels}
  594.     canvas.framerect(rect(left-1,top-1,right+2,bottom+2));
  595.     canvas.brush.color := clblack;      {black frame around white}
  596.     canvas.framerect(CropHands[INNER]);
  597.     corner(UR,right,top);                            
  598.     corner(UL,left,top);                
  599.     corner(BR,right,bottom);
  600.     corner(BL,left,bottom); 
  601.     corner(RS,right,(bottom + top) div 2); 
  602.     corner(LS,left,(bottom + top) div 2); 
  603.     corner(TS,(right + left) div 2,top); 
  604.     corner(BS,(right + left) div 2,bottom); 
  605.   end;         
  606. end;
  607.  
  608. {------------------------------------------------------------------------}
  609. procedure TSimage.croptool_on;
  610. begin;
  611.   if CropToolOn then exit;
  612.   CropToolOn := yes;
  613.   CropChanged := no;
  614.   CropCopy := TBitmap.create;
  615.   CropCopy.assign(picture.bitmap);
  616.   if not valid_crop then
  617.     with CropRectActual, origpict do
  618.     begin
  619.       left := width div 4;
  620.       right := 3 * left;
  621.       top := height div 4;
  622.       bottom := 3 * top;
  623.     end;
  624.   with CropRectActual do
  625.   begin
  626.     CropRectScaled.left   := trunc(left   * sratio);
  627.     CropRectScaled.right  := trunc(right  * sratio);
  628.     CropRectScaled.top    := trunc(top    * sratio);
  629.     CropRectScaled.bottom := trunc(bottom * sratio);
  630.   end;
  631.   draw_croptool(CropRectScaled);    
  632. end;                               
  633.  
  634. {no Initialization Block}
  635. {------------------------------------------------------------------------}
  636. end.
  637.